home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_003 / xlisp / xlsubr.c < prev    next >
C/C++ Source or Header  |  1992-05-06  |  4KB  |  211 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *k_test,*k_tnot,*s_eql;
  7. extern NODE *xlstack;
  8.  
  9. /* xlsubr - define a builtin function */
  10. xlsubr(sname,type,subr)
  11.   char *sname; int type; NODE *(*subr)();
  12. {
  13.     NODE *sym;
  14.  
  15.     /* enter the symbol */
  16.     sym = xlsenter(sname);
  17.  
  18.     /* initialize the value */
  19.     sym->n_symvalue = newnode(type);
  20.     sym->n_symvalue->n_subr = subr;
  21. }
  22.  
  23. /* xlarg - get the next argument */
  24. NODE *xlarg(pargs)
  25.   NODE **pargs;
  26. {
  27.     NODE *arg;
  28.  
  29.     /* make sure the argument exists */
  30.     if (!consp(*pargs))
  31.     xlfail("too few arguments");
  32.  
  33.     /* get the argument value */
  34.     arg = car(*pargs);
  35.  
  36.     /* make sure its not a keyword */
  37.     if (symbolp(arg) && *car(arg->n_symplist)->n_str == ':')
  38.     xlfail("too few arguments");
  39.  
  40.     /* move the argument pointer ahead */
  41.     *pargs = cdr(*pargs);
  42.  
  43.     /* return the argument */
  44.     return (arg);
  45. }
  46.  
  47. /* xlmatch - get an argument and match its type */
  48. NODE *xlmatch(type,pargs)
  49.   int type; NODE **pargs;
  50. {
  51.     NODE *arg;
  52.  
  53.     /* get the argument */
  54.     arg = xlarg(pargs);
  55.  
  56.     /* check its type */
  57.     if (type == LIST) {
  58.     if (arg && ntype(arg) != LIST)
  59.         xlfail("bad argument type");
  60.     }
  61.     else {
  62.     if (arg == NIL || ntype(arg) != type)
  63.         xlfail("bad argument type");
  64.     }
  65.  
  66.     /* return the argument */
  67.     return (arg);
  68. }
  69.  
  70. /* xlevarg - get the next argument and evaluate it */
  71. NODE *xlevarg(pargs)
  72.   NODE **pargs;
  73. {
  74.     NODE *oldstk,val;
  75.  
  76.     /* create a new stack frame */
  77.     oldstk = xlsave(&val,NULL);
  78.  
  79.     /* get the argument */
  80.     val.n_ptr = xlarg(pargs);
  81.  
  82.     /* evaluate the argument */
  83.     val.n_ptr = xleval(val.n_ptr);
  84.  
  85.     /* restore the previous stack frame */
  86.     xlstack = oldstk;
  87.  
  88.     /* return the argument */
  89.     return (val.n_ptr);
  90. }
  91.  
  92. /* xlevmatch - get an evaluated argument and match its type */
  93. NODE *xlevmatch(type,pargs)
  94.   int type; NODE **pargs;
  95. {
  96.     NODE *arg;
  97.  
  98.     /* get the argument */
  99.     arg = xlevarg(pargs);
  100.  
  101.     /* check its type */
  102.     if (type == LIST) {
  103.     if (arg && ntype(arg) != LIST)
  104.         xlfail("bad argument type");
  105.     }
  106.     else {
  107.     if (arg == NIL || ntype(arg) != type)
  108.         xlfail("bad argument type");
  109.     }
  110.  
  111.     /* return the argument */
  112.     return (arg);
  113. }
  114.  
  115. /* xltest - get the :test or :test-not keyword argument */
  116. xltest(pfcn,ptresult,pargs)
  117.   NODE **pfcn; int *ptresult; NODE **pargs;
  118. {
  119.     NODE *arg;
  120.  
  121.     /* default the argument to eql */
  122.     if (!consp(*pargs)) {
  123.     *pfcn = s_eql->n_symvalue;
  124.     *ptresult = TRUE;
  125.     return;
  126.     }
  127.  
  128.     /* get the keyword */
  129.     arg = car(*pargs);
  130.  
  131.     /* check the keyword */
  132.     if (arg == k_test)
  133.     *ptresult = TRUE;
  134.     else if (arg == k_tnot)
  135.     *ptresult = FALSE;
  136.     else
  137.     xlfail("expecting :test or :test-not");
  138.  
  139.     /* move the argument pointer ahead */
  140.     *pargs = cdr(*pargs);
  141.  
  142.     /* make sure the argument exists */
  143.     if (!consp(*pargs))
  144.     xlfail("no value for keyword argument");
  145.  
  146.     /* get the argument value */
  147.     *pfcn = car(*pargs);
  148.  
  149.     /* if its a symbol, get its value */
  150.     if (symbolp(*pfcn))
  151.     *pfcn = xleval(*pfcn);
  152.  
  153.     /* move the argument pointer ahead */
  154.     *pargs = cdr(*pargs);
  155. }
  156.  
  157. /* xllastarg - make sure the remainder of the argument list is empty */
  158. xllastarg(args)
  159.   NODE *args;
  160. {
  161.     if (args)
  162.     xlfail("too many arguments");
  163. }
  164.  
  165. /* assign - assign a value to a symbol */
  166. assign(sym,val)
  167.   NODE *sym,*val;
  168. {
  169.     NODE *lptr;
  170.  
  171.     /* check for a current object */
  172.     if ((lptr = xlobsym(sym)) != NIL)
  173.     rplaca(lptr,val);
  174.     else
  175.     sym->n_symvalue = val;
  176. }
  177.  
  178. /* eq - internal eq function */
  179. int eq(arg1,arg2)
  180.   NODE *arg1,*arg2;
  181. {
  182.     return (arg1 == arg2);
  183. }
  184.  
  185. /* eql - internal eql function */
  186. int eql(arg1,arg2)
  187.   NODE *arg1,*arg2;
  188. {
  189.     if (eq(arg1,arg2))
  190.     return (TRUE);
  191.     else if (fixp(arg1) && fixp(arg2))
  192.     return (arg1->n_int == arg2->n_int);
  193.     else if (stringp(arg1) && stringp(arg2))
  194.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  195.     else
  196.     return (FALSE);
  197. }
  198.  
  199. /* equal - internal equal function */
  200. int equal(arg1,arg2)
  201.   NODE *arg1,*arg2;
  202. {
  203.     /* compare the arguments */
  204.     if (eql(arg1,arg2))
  205.     return (TRUE);
  206.     else if (consp(arg1) && consp(arg2))
  207.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  208.     else
  209.     return (FALSE);
  210. }
  211.